COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload util fas dsk (aid rpg)))
C00015 ENDMK
C⊗;
(declare (fasload util fas dsk (aid rpg)))
(declare (special *dest *source *file *ext *p *pn *switches *q) (*lexpr %match))

(macrodef implode-ext (x) (cond ((null x) '←←←)
				(t (implode x))))
(macrodef flush-last (ll)
 (let l ← ll
      then
      aa bb ← l (cddr l)
      do
      (while bb do
	     (setq aa (cdr aa)
		   bb (cdr bb)))
      (rplacd aa ())
      l))

(defun transduce-read (message def-ext)
       (terpri)(and message (princ message) (tyo 32.))
       (let syn1 ← (status syntax 44.)
	    syn2 ← (status syntax 46.)
	    syn3 ← (status syntax 91.)
	    syn4 ← (status syntax 93.)
	    syn5 ← (status syntax 40.)
	    syn6 ← (status syntax 41.)
	    mac1 ← (status macro 44.)
	    mac2 ← (status macro 46.)
	    mac3 ← (status macro 91.)
	    mac4 ← (status macro 93.)
	    do
	    (setsyntax 44. 2 44.)
	    (setsyntax 46. 2 46.)
	    (setsyntax 91. 2 91.)
	    (setsyntax 93. 2. 93.)
	    (setsyntax 40. 2. 40.)
	    (setsyntax 41. 2. 41.)
	    (let x ← (unwind-protect 
		      (read)
		      (setsyntax 44. syn1 44.)
		      (setsyntax 46. syn2 46.)
		      (setsyntax 91. syn3 91.)
		      (setsyntax 93. syn4 93.)
		      (setsyntax 40. syn5 40.)
		      (setsyntax 41. syn6 41.)
		      (and mac1 (sstatus macro 44. (car mac1)))
		      (and mac2 (sstatus macro 46. (car mac2)))
		      (and mac3 (sstatus macro 91. (car mac3)))
		      (and mac4 (sstatus macro 93. (car mac4))))
		 *file *ext *p *pn *switches ← nil nil nil nil
		 do
		 (cond ((eq x 'quit) (↑g))
		       (t
			(let source dest ← () ()
			     *source *dest ← () ()
			     *switches ← ()
			     input ← (for i ε 
					  (explode x) select (not (memq i '(/| // /]))))
			     do
			     (cond ((not (%match '(*dest /← *source) input))
				    (setq *source input))) 
			     (or (%match '(*source /( *switches /)) *source)
				 (%match '(*source /( *switches) *source))
			     (setq source
				   (cond (
					  (%match '(*file /. *ext /[ *p /,)
						  *source)
					  `((dsk (,(implode *p) ,(cadr (status udir))))
					    ,(implode *file),(implode-ext *ext)))  
					  ((%match '(*file /. *ext /[ *p /, *pn)
						  *source)
					  `((dsk (,(implode *p) ,(implode *pn))
						 ,(implode *file),(implode-ext  *ext))))     
					 ((%match '(*file /. *ext /[) *source)
					  `((dsk ,(status udir))
					    ,(implode *file),(implode-ext *ext)))  
					 ((%match '(*file /. *ext /[ *p)
						  *source)
					  `((dsk (,(implode *p) ,(cadr (status udir))))
					    ,(implode *file),(implode-ext *ext)))

					 ((%match '(*file /[ *p /,)
						  *source)
					  `((dsk (,(implode *p) ,(cadr (status udir))))
					    ,(implode *file) ←←←))
					 ((%match '(*file /[ *p /, *pn)
						  *source)
					  `((dsk (,(implode *p) ,(implode *pn)))
					    ,(implode *file) ←←←))     
					 ((%match '(*file /[ *p)
						  *source)
					  `((dsk (,(implode *p) ,(cadr (status udir))))
					    ,(implode *file) ←←←))
					 ((%match '(*file /[) *source)
					  `((dsk ,(status udir))
					    ,(implode *file) ←←←))

					 ((%match '(*file /. *ext) *source)
					  `((dsk ,(status udir))
					    ,(implode *file),(implode-ext *ext)))
					 ((%match '(*file) *source)
					  `((dsk ,(status udir))
					    ,(implode *file) ←←←))
					 (t 
					  (transduce-read
					   '|Guess again!!!| def-ext))))  
			     
			     (cond (*dest
				    (setq dest
					  (cond (
						(%match '(*file /. *ext /[ *p /,)
							 *dest)
						 `((dsk (,(implode *p),(cadr (status udir))))
						   ,(implode *file),(implode-ext *ext)))
						 ((%match '(*file /. *ext /[ *p /, *pn)
							 *dest)
						 `((dsk (,(implode *p),(implode *pn)))
						   ,(implode *file),(implode-ext  *ext)))     
						((%match '(*file /. *ext /[) *dest)
						 `((dsk ,(status udir))
						   ,(implode *file),(implode-ext *ext)))
						((%match '(*file /. *ext /[ *p)
							 *dest)
						 `((dsk (,(implode *p) ,(cadr (status udir))))
						   ,(implode *file),(implode-ext *ext)))
						
						((%match '(*file /[ *p /,)
							 *dest)
						 `((dsk (,(implode *p),(cadr (status udir))))
						   ,(implode *file) ←←←))
						((%match '(*file /[ *p /, *pn)
							 *dest)
						 `((dsk (,(implode *p),(implode *pn)))
						   ,(implode *file) ←←←))     
						((%match '(*file /[ *p)
							 *dest)
						 `((dsk (,(implode *p),(cadr (status udir))))
						   ,(implode *file) ←←←))
						((%match '(*file /[) *dest)
						 `((dsk ,(status udir))
						   ,(implode *file) ←←←))
						
						((%match '(*file /. *ext) *dest)
						 `(,(car source)
						   ,(implode *file),(implode-ext *ext)))
						((%match '(*file) *dest)
						 `(,(car source)
						   ,(implode *file) ,def-ext))
						(t 
						 (transduce-read
						  '|Guess again!!!| def-ext))))  )
				   (t (setq dest (subst () () source))
				      (and (cddr dest) (rplaca (cddr dest) def-ext))))
			     (list dest source *switches)))))))   
		       
(defun read-filename (message)
       (and message (terpri))
       (and message (princ message)(tyo 32.))
       (let syn1 ← (status syntax 44.)
	    syn2 ← (status syntax 46.)
	    syn3 ← (status syntax 91.)
	    syn4 ← (status syntax 93.)
	    syn5 ← (status syntax 40.)
	    syn6 ← (status syntax 41.)
	    mac1 ← (status macro 44.)
	    mac2 ← (status macro 46.)
	    mac3 ← (status macro 91.)
	    mac4 ← (status macro 93.)
	    do
	    (setsyntax 44. 2 44.)
	    (setsyntax 46. 2 46.)
	    (setsyntax 91. 2 91.)
	    (setsyntax 93. 2. 93.)
	    (setsyntax 40. 2 40.)
	    (setsyntax 41. 2 41.)
	    (let x ← (unwind-protect 
		      (read)
		      (setsyntax 44. syn1 44.)
		      (setsyntax 46. syn2 46.)
		      (setsyntax 91. syn3 91.)
		      (setsyntax 93. syn4 93.)
		      (setsyntax 40. syn5 40.)
		      (setsyntax 41. syn6 41.)
		      (and mac1 (sstatus macro 44. (car mac1)))
		      (and mac2 (sstatus macro 46. (car mac2)))
		      (and mac3 (sstatus macro 91. (car mac3)))
		      (and mac4 (sstatus macro 93. (car mac4))))
		 *file *ext *p *pn *switches ← nil nil nil nil nil
		 filespec ← nil
		 do
		 (cond ((eq x 'quit) (↑g))
		       (t (let *q ← (for i ε 
					(explode x) select (not (memq i '(/| // /]))))
			       do
			       (or 
				(%match '(*q /( *switches /)) *q)
				(%match '(*q /( *switches ) *q))
			       (setq filespec
				     (cond (
					    (%match '(*file /. *ext /[ *p /,)
						    *q)
					    `((dsk (,(implode *p) ,(cadr (status udir))))
					      ,(implode *file),(implode-ext *ext)))
					   ((%match '(*file /. *ext /[ *p /, *pn)
						    *q)
					    `((dsk (,(implode *p) ,(implode *pn)))
					      ,(implode *file),(implode-ext *ext)))     
					   ((%match '(*file /. *ext /[) *q)
					    `((dsk ,(status udir))
					      ,(implode *file),(implode-ext *ext)))
					   ((%match '(*file /. *ext /[ *p)
						    *q)
					    `((dsk (,(implode *p),(cadr (status udir))))
					      ,(implode *file),(implode-ext *ext)))
					   
					   ((%match '(*file /[ *p /,)
						    *q)
					    `((dsk (,(implode *p),(cadr (status udir))))
					      ,(implode *file) ←←←))
					   ((%match '(*file /[ *p /, *pn)
						    *q)
					    `((dsk (,(implode *p),(implode *pn)))
					      ,(implode *file) ←←←))     
					   ((%match '(*file /[ *p)
						    *q)
					    `((dsk (,(implode *p) ,(cadr (status udir))))
					      ,(implode *file) ←←←))
					   ((%match '(*file /[) *q)
					    `((dsk ,(status udir))
					      ,(implode *file) ←←←))
					   
					   ((%match '(*file /. *ext) *q)
					    `((dsk ,(status udir))
					      ,(implode *file),(implode-ext *ext)))
					   ((%match '(*file) *q)
					    x)
					   (t 
					    (read-filename
					     '|Guess again!!!|))))
			       `(,filespec ,*switches))))))))